home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / cmplangm / 1989_4 / env / envtest.pas < prev    next >
Pascal/Delphi Source File  |  1988-09-26  |  12KB  |  480 lines
  1. (* Turbo Pascal version 4 *)
  2. {$B-,D-,F-,I-,L+,N-,R-,S-,T-,V-}
  3. {$M 4096,0,0}
  4.  
  5. PROGRAM Evntest;
  6.  
  7.   { UNIT Env test }
  8.  
  9. USES Dos, Crt;
  10.  
  11. TYPE
  12.   Str4 = string[4];
  13.  
  14. VAR
  15.   UseCurrentEnv : boolean;  { true if current environment is accessed }
  16.   SecondCommand : boolean;  { true if secondary COMMAND.COM is loaded }
  17.   EnvAddr       : word;     { environment address }
  18.   EnvSize       : integer;  { environment size }
  19.   EnvTyp        : byte;     { environment type }
  20.   RootEnvAddr   : word;     { root environment address }
  21.   RootEnvSize   : integer;  { root environment size }
  22.   Regs          : Registers;
  23.   EnvStr        : string;
  24.   EnvParam      : string;
  25.   EnvVar        : string;
  26.  
  27. FUNCTION Hex(i : integer): Str4;
  28.  
  29.       { convert an integer to hex string }
  30. CONST
  31.   HexCh : array[0..15] of char = '0123456789ABCDEF';
  32.  
  33. VAR
  34.   Temp   : byte;
  35.   TempSt : string[2];
  36.  
  37. begin
  38.   Temp := hi(i);
  39.   TempSt := HexCh[Temp shr 4] + HexCh[Temp and $0F];
  40.   Temp := lo(i);
  41.   Hex := TempSt + HexCh[Temp shr 4] + HexCh[Temp and $0F];
  42. end;  { Hex }
  43.  
  44. PROCEDURE GetEnvTyp(VAR EnvTyp : byte);
  45.  
  46. VAR
  47.   Major : byte;  { major DOS version number }
  48.   Minor : byte;  { minor DOS version number }
  49.  
  50. begin
  51.  
  52.       { get DOS version }
  53.   with Regs do
  54.     begin
  55.       AX := $3000;
  56.       MSDos(Regs);
  57.       Major := Lo(AX);
  58.       Minor := Hi(AX);
  59.     end;
  60.  
  61.       { assign environment type according to DOS version }
  62.   case Major of
  63.     2 : EnvTyp := 1;
  64.     3 : case Minor of
  65.           0, 10 : EnvTyp := 1;
  66.           20    : EnvTyp := 2;
  67.           30    : EnvTyp := 3;
  68.         end;
  69.     4 : EnvTyp := 3;
  70.     else
  71.       begin
  72.         Writeln('Unknown DOS version');
  73.         Halt;
  74.       end;
  75.   end;  { case }
  76.   Writeln('DOS version              : ',Major,'.',Minor);
  77.   Writeln('Environment type         : ',EnvTyp);
  78. end;  { GetEnvTyp }
  79.  
  80. PROCEDURE SearchMemory(VAR RootEnvaddr : word; VAR RootEnvSize : integer);
  81.  
  82.       { search memory for root environment }
  83. VAR
  84.   ComMCB  : word;     { COMMAND.COM MCB }
  85.   EnvMCB  : word;     { environment MCB }
  86.   MCBsize : word;     { memory block size in paragraphs }
  87.   Found   : boolean;  { root COMMAND.COM found }
  88.  
  89. PROCEDURE CheckMCBchain(ComMCB : word; VAR EnvMCB : word;
  90.                         VAR Found : boolean);
  91.  
  92.       { check for Memory Control Block chain }
  93.  
  94. begin
  95.   Found := false;
  96.   MCBsize := MemW[ComMCB : 3];
  97.   EnvMCB := Succ(ComMCB + MCBsize);
  98.   if (Mem[EnvMCB : 0] = $4D) then
  99.     Found := true;
  100. end;  { CheckMCBchain }
  101.  
  102. begin  { SearchMemory }
  103.  
  104.       { begin search for COMMAND.COM in low memory }
  105.   ComMCB := $500;
  106.   Found := false;
  107.   while not Found do
  108.     begin
  109.  
  110.       { MCB begins with $4D }
  111.       if Mem[ComMCB:0] = $4D then
  112.         begin
  113.  
  114.       { check for matching PSP address }
  115.           if MemW[ComMCB : 1] = Succ(ComMCB) then
  116.             CheckMCBchain(ComMCB,EnvMCB,Found);
  117.         end;
  118.  
  119.       { if not Found then continue search at next paragraph boundary }
  120.       Inc(ComMCB);
  121.     end;  { while }
  122.   Writeln('Root PSP address         : ',Hex(ComMCB));
  123.  
  124.       { check for environment type }
  125.   if MemW[ComMCB : $2C] = 0 then
  126.  
  127.       { root environment of DOS 2.0 - 3.2 }
  128.     begin
  129.       RootEnvAddr := Succ(EnvMCB);
  130.       MCBsize := MemW[EnvMCB : 3];
  131.       RootEnvSize := MCBsize * $10;
  132.     end
  133.   else
  134.  
  135.       { root environment of DOS 3.3 - 4.0 }
  136.     begin
  137.       RootEnvAddr := MemW[ComMCB : $2C];
  138.       EnvMCB := Pred(RootEnvaddr);
  139.       MCBsize := MemW[EnvMCB : 3];
  140.       RootEnvSize := MCBsize * $10;
  141.     end;  { if }
  142. end;  { SearchMemory }
  143.  
  144. PROCEDURE GetEnv(VAR EnvAddr : word; VAR EnvSize : integer;
  145.                  VAR RootEnvAddr : word; VAR RootEnvSize : integer;
  146.                  EnvTyp : byte);
  147. VAR
  148.   PSPaddr : word;  { COMMAND.COM PSP address }
  149.   ComMCB  : word;  { COMMAND.COM MCB }
  150.   EnvMCB  : word;  { environment MCB }
  151.   MCBsize : word;  { memory block size in paragraphs }
  152.  
  153. begin
  154.   RootEnvAddr := 0;
  155.  
  156.       { COMMAND.COM PSP address at offset $16 in program PSP }
  157.   PSPaddr := MemW[PrefixSeg : $16];
  158.  
  159.       { check for child process }
  160.   while (PSPaddr <> MemW[PSPaddr : $16]) do
  161.     PSPaddr := MemW[PSPaddr : $16];
  162.  
  163.       { COMMAND.COM MCB address }
  164.   ComMCB := Pred(PSPaddr);
  165.  
  166.       { size of COMMAND.COM }
  167.   MCBsize := MemW[ComMCB : 3];
  168.  
  169.       { environment MCB address }
  170.   EnvMCB := PSPaddr + MCBsize;
  171.  
  172.       { assign environment address }
  173.   EnvAddr := Succ(EnvMCB);
  174.  
  175.       { size of environment }
  176.   MCBsize := MemW[EnvMCB : 3];
  177.   EnvSize := MCBsize * $10;
  178.  
  179.       { check for secondary COMMAND.COM }
  180.   case EnvTyp of
  181.  
  182.       { $2C points to DOS environment in DOS 2.0 - 3.1 }
  183.     1 : if (MemW[PSPaddr : $2C] <> 0) then
  184.           begin
  185.             SearchMemory(RootEnvAddr,RootEnvSize);
  186.  
  187.       { re-assign environment address }
  188.             EnvAddr := MemW[PSPaddr : $2C];
  189.             EnvMCB := Pred(Envaddr);
  190.             MCBsize := MemW[EnvMCB : 3];
  191.             EnvSize := MCBsize * $10;
  192.           end;
  193.  
  194.       { $2C points to program environment in DOS 3.2 }
  195.     2 : if (MemW[PSPaddr : $2C] <> 0) then
  196.           SearchMemory(RootEnvAddr,RootEnvSize);
  197.  
  198.       { $2C points to DOS environment in DOS 3.3 - 4.0 }
  199.     3 : if (MemW[PSPaddr : $2C] = EnvAddr) then
  200.           SearchMemory(RootEnvAddr,RootEnvSize)
  201.         else
  202.  
  203.       { re-assign environment address }
  204.           begin
  205.             EnvAddr := MemW[PSPaddr : $2C];
  206.             EnvMCB := Pred(Envaddr);
  207.             MCBsize := MemW[EnvMCB : 3];
  208.             EnvSize := MCBsize * $10;
  209.           end;
  210.   end;  { case }
  211.   Writeln('Current PSP address      : ',Hex(PSPaddr));
  212. end;  { GetEnv }
  213.  
  214. FUNCTION UpStr(St : string) : string;
  215.  
  216.       { convert a string to upper case }
  217. VAR
  218.   i : byte;
  219.  
  220. begin
  221.   for i := 1 to Length(St) do
  222.     St[i] := UpCase(St[i]);
  223.   UpStr := St;
  224. end;  { UpStr }
  225.  
  226. FUNCTION Position(St : string; EnvAddr : word; ArrayLen : integer) : integer;
  227.  
  228.       { find the position of a string in the environment array }
  229. VAR
  230.   Found : boolean;
  231.   Match : boolean;
  232.   StLen : integer;
  233.   i     : integer;
  234.   p     : integer;
  235.  
  236. begin
  237.   Found := false;
  238.   StLen := Length(St);
  239.   p := 0;
  240.   while (not Found) and ((ArrayLen - p+1) >= StLen) do
  241.  
  242.       { find first match }
  243.     begin
  244.       if St[1] = Chr(Mem[EnvAddr : p]) then
  245.  
  246.       { find next match }
  247.       begin
  248.         Match := true;
  249.         i := 1;
  250.         while Match and (i < StLen) do
  251.           if St[1+i] = Chr(Mem[EnvAddr : p+i]) then
  252.             Inc(i)
  253.           else
  254.             Match := false;
  255.         Found := Match;
  256.         end;
  257.       if not Found then
  258.         Inc(p);
  259.     end;
  260.   if found then
  261.     Position := p
  262.   else
  263.     Position := -1;
  264. end;  {  Position  }
  265.  
  266. PROCEDURE ReadEnvVar(EnvParam : string; VAR EnvVar : string);
  267.  
  268. VAR
  269.   ArrayLen : integer;  { environment array length }
  270.   ParamPos : integer;  { parameter position }
  271.   VarPos   : integer;  { variable position }
  272.   i        : integer;
  273.  
  274. begin
  275.   if EnvParam = '' then
  276.     Exit;
  277.   if not UseCurrentEnv then
  278.     begin
  279.       EnvAddr := RootEnvAddr;
  280.       EnvSize := RootEnvSize;
  281.     end;
  282.  
  283.       { check if environment is empty }
  284.   if Mem[EnvAddr : 0] = 0 then
  285.     Exit
  286.    else
  287.      begin
  288.  
  289.       { get the length of the environment string }
  290.         ArrayLen := Position(#0#0,EnvAddr,EnvSize);
  291.         if ArrayLen = -1 then
  292.           begin
  293.             Writeln('End of environment not found');
  294.             Halt;
  295.           end;
  296.      end;  { else }
  297.  
  298.       { initialize variables }
  299.   EnvParam := UpStr(EnvParam) + '=';
  300.   EnvVar := '';
  301.  
  302.       { search for variable in environment }
  303.   ParamPos := Position(EnvParam,EnvAddr,ArrayLen);
  304.   if ParamPos = -1 then
  305.     Exit
  306.  
  307.       { environment parameter found }
  308.       { get length of variable string }
  309.    else
  310.      begin
  311.        ParamPos := ParamPos + Length(EnvParam);
  312.        VarPos := ParamPos;
  313.        while Mem[EnvAddr : VarPos] <> 0 do
  314.          Inc(VarPos);
  315.  
  316.       { assign environment variable }
  317.        Move(Mem[EnvAddr:ParamPos], EnvVar[1], VarPos-ParamPos);
  318.        EnvVar[0] := Chr(VarPos-ParamPos);
  319.      end;  { else }
  320. end;  { ReadEnvVar }
  321.  
  322. PROCEDURE WriteEnvVar(EnvParam, EnvVar : string);
  323.  
  324. VAR
  325.   ArrayLen : integer;  { environment array length }
  326.   EnvStr   : string;   { environment string }
  327.   StLen    : integer;  { environment string length }
  328.   ParamPos : integer;  { parameter position }
  329.   i        : integer;
  330.  
  331. begin
  332.   if EnvParam = '' then
  333.     Exit;
  334.   if not UseCurrentEnv then
  335.     begin
  336.       EnvAddr := RootEnvAddr;
  337.       EnvSize := RootEnvSize;
  338.     end;
  339.  
  340.       { check if environment is empty }
  341.   if Mem[EnvAddr : 0] = 0 then
  342.     ArrayLen := 0
  343.    else
  344.      begin
  345.  
  346.       { get the length of the environment string }
  347.         ArrayLen := Position(#0#0,EnvAddr,EnvSize);
  348.  
  349.         if ArrayLen = -1 then
  350.           begin
  351.             Writeln('End of environment not found');
  352.             Halt;
  353.           end;
  354.      end;  { else }
  355.  
  356.       { initialize variables }
  357.   EnvParam := UpStr(EnvParam) + '=';
  358.   EnvStr := EnvParam + EnvVar + #0#0;
  359.   StLen := Length(EnvStr);
  360.  
  361.       { search for variable in environment }
  362.   ParamPos := Position(EnvParam,EnvAddr,ArrayLen);
  363.  
  364.   if ParamPos = -1 then
  365.     begin
  366.  
  367.       { check for empty variable }
  368.         if EnvVar = '' then
  369.           Exit;
  370.  
  371.       { environment parameter not found }
  372.       { compare environment with string }
  373.         if (ArrayLen + StLen + 1) > EnvSize then
  374.           Writeln('Environment full')
  375.         else
  376.  
  377.       { add new variable string to end of array }
  378.           begin
  379.             if ArrayLen = 0 then
  380.               Move(EnvStr[1], Mem[EnvAddr : 0], StLen)
  381.             else
  382.               Move(EnvStr[1], Mem[EnvAddr : ArrayLen+1], StLen);
  383.           end;
  384.     end  { if }
  385.  
  386.       { environment parameter found }
  387.       { get length of variable string }
  388.   else
  389.     begin
  390.  
  391.       { skip three characters in array }
  392.       i := ParamPos + 3;
  393.       while Mem[EnvAddr : i] <> 0 do
  394.         Inc(i);
  395.  
  396.       { get beginning of next variable string }
  397.         Inc(i);
  398.  
  399.       { delete variable from current position in array }
  400.         Move(Mem[EnvAddr: i], Mem[EnvAddr: ParamPos], (ArrayLen+2)-i);
  401.         ArrayLen := ArrayLen - (i-ParamPos);
  402.  
  403.       { check for empty variable }
  404.        if EnvVar = '' then
  405.          Exit;
  406.  
  407.       { compare environment array length with environment size }
  408.        if (ArrayLen + StLen + 1) > EnvSize then
  409.          Writeln('Environment full')
  410.        else
  411.  
  412.       { add variable to end of array }
  413.          Move(EnvStr[1], Mem[EnvAddr : ArrayLen+1], StLen);
  414.      end;  { else }
  415. end;  { WriteEnvVar }
  416.  
  417. procedure GetParams(EnvStr : string; var EnvParam, EnvVar : string);
  418.  
  419. var
  420.   p     : integer;
  421.  
  422. begin
  423.   p := Pos('=',EnvStr);
  424.   if p <= 1 then
  425.     begin
  426.       Writeln('Invalid parameter');
  427.       EnvParam := '';
  428.       EnvVar := '';
  429.       Exit;
  430.     end;
  431.   EnvParam := UpStr(Copy(EnvStr,1,p-1));
  432.   EnvVar := Copy(EnvStr,p+1,Length(EnvStr));
  433. end;  { GetParams }
  434.  
  435.  
  436. begin  { Env }
  437.  
  438.       { initialize environment address }
  439.   UseCurrentEnv := true;
  440.   SecondCommand := true;
  441.   GetEnvTyp(EnvTyp);
  442.   GetEnv(EnvAddr,EnvSize,RootEnvAddr,RootEnvSize,EnvTyp);
  443.   if RootEnvAddr = 0 then
  444.     begin
  445.       RootEnvAddr := EnvAddr;
  446.       RootEnvSize := EnvSize;
  447.       SecondCommand := false;
  448.     end;
  449.  
  450.       { print environment address }
  451.   if SecondCommand then
  452.     begin
  453.       Writeln('Root environment address : ',Hex(RootEnvAddr));
  454.       Writeln('Root environment size    : ',RootEnvSize);
  455.     end;
  456.   Writeln('Environment address      : ',Hex(EnvAddr));
  457.   Writeln('Environment size         : ',EnvSize);
  458.   Writeln;
  459.  
  460.       { test reading and writing}
  461.   Write('Add environment variable    :');
  462.   Readln(EnvStr);
  463.   GetParams(EnvStr,EnvParam,EnvVar);
  464.   WriteEnvVar(EnvParam,EnvVar);
  465.   Write('Change environment variable :');
  466.   Readln(EnvStr);
  467.   GetParams(EnvStr,EnvParam,EnvVar);
  468.   WriteEnvVar(EnvParam,EnvVar);
  469.   Write('Show environment variable   :');
  470.   Readln(EnvParam);
  471.   EnvParam := UpStr(EnvParam);
  472.   ReadEnvVar(EnvParam,EnvVar);
  473.   Writeln('   ',EnvParam,'=',EnvVar);
  474.   Write('Delete environment variable :');
  475.   Readln(EnvParam);
  476.   EnvParam := UpStr(EnvParam);
  477.   EnvVar := '';
  478.   WriteEnvVar(EnvParam,EnvVar);
  479. end.  { Env }
  480.